home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
CD ROM Paradise Collection 4
/
CD ROM Paradise Collection 4 1995 Nov.iso
/
program
/
jx4nt123.zip
/
JAX4TH.I
< prev
next >
Wrap
Text File
|
1994-09-05
|
12KB
|
441 lines
; jax4th.inc ... 32-bit ANS Forth for Windows NT
; copyright (c) 1993, 1994 by jack j. woehr
; p.o. box 51, golden, co 80402-0051
; jax@well.sf.ca.us | JAX on GEnie | 72203.1320@compuserve.com
; sysop, rcfb (303) 278-0364
COMMENT !
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details. (doc\license.txt)
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */
!
;-----------------------;
; Register equates ;
;-----------------------;
ip textequ <esi> ; Forth instruction pointer
dsp textequ <esp> ; Forth data stack pointer
rp textequ <ebp> ; Forth return stack pointer
wp textequ <eax> ; Indirect-threading word pointer
cp textequ <edi> ; Pointer to user dictionary
dp textequ <ebx> ; Pointer to data space
;---------------;
; Constants ;
;---------------;
; Scaling
tchar equ 2 ; Unicode characters
cell equ 4 ; 32-bit Forth, byte-addressing processor
; Boolean
TRUE equ 0FFFFFFFFH
FALSE equ 0
; Chars
UniNotAChar equ 0FFFFH ; illegal Unicode char
cRet equ 000DH ; carriage return
lFeed equ 000AH ; line feed
;---------------;
; Bit Masks ;
;---------------;
immedMask equ 8000H ; in name count word, marks word as immediate
allNameMasks equ immedMask ; all non-count bits used in name count word
userdictbit equ 31
userdictmask equ 80000000H
;-----------------------;
; System factors ;
;-----------------------;
dStackSize equ 4000H ; half for data stack
rStackSize equ 4000H ; half for return
stackstackSize equ dStackSize + rStackSize ; complete stack allocation, as requested in linker statement in makefile
defDataSize equ 10000H ; default data space size
defDictSize equ 10000H ; default user dictionary size
tibsize equ 256 ; terminal input buffer size
searchOrderSize equ 8 ; max wordlists in search order
blockSize equ 1024 ; number of chars in a BLOCK
rlbuffsize equ tibsize ; maximum chars for READ-LINE is same as TIB for now
;---------------;
; Error Returns ;
;---------------;
userErr equ 2000000H ; No Windows API error code has bit 29 set ( 0x20000000)
;---------------;
; Macros ;
;---------------;
;--( System Macros )
; Embed a string as Unicode
unicode macro aString
irpc x,<aString>
db '&x',0 ;; assemble as little-endian double-byte char
endm
endm
;--( Code Macros )
; Store to a Forth VARIABLE offset from assembly
store macro dataOffset,source
mov DWORD PTR [dp+dataOffset],source
endm
; Fetch From a Forth VARIABLE offset from assembly
fetch macro dest,dataOffset
mov dest,DWORD PTR [dp+dataOffset]
endm
;--( Dictionary Macros )
; Assign offsets in data space for Forth variables.
varptr = 0 ; an allocation pointer
avar macro varName
varName = varptr
varptr = varptr+cell
endm
; Assembly-time allocation of data space by cells
allotCells macro aName,numCells
aName = varptr
varptr = varptr + (numCells*cell)
endm
; Back-links at head of various wordlists, single-threaded
flinkptr = 0 ; FORTH-WORDLIST Standard words
zlinkptr = 0 ; INTERNALS-WORDLIST Internals
nlinkptr = 0 ; NONSTANDARD-WORDLIST Non-standard Forth words
slinkptr = 0 ; SYSTEM-WORDLIST System calls, etc.
linkme macro linkpointer
align cell
dd linkpointer ;; embedded back-link
linkpointer = $-cell ;; point to address at which link pointer was compiled
endm
; Create a count DWORD consisting of 0xFFFF followed by the character count so that an unambguous marker may be
; found when searching back from the CFA.
countcell macro aCount
align cell
dw 0FFFFH
dw aCount
endm
; Create a non-IMMEDIATE name header consisting of count char and name chars.
; Mostly called by macro NAME, but this factoring is necessary because of chars like * / # in Forth names.
namemanque macro aName,linkpointer
linkme linkpointer
namecntr = 0
irpc x,aName
namecntr = namecntr+1
endm
countcell namecntr
unicode aName
align cell
endm
; Create a non-IMMEDIATE name header consisting of count char and name chars as above,
; but also define a token label for it. This is the normal call. NAYME is spelled funny because NAME is MASM keyword.
nayme macro aName,linkpointer
namemanque aName,linkpointer
fw_&aName:
endm
; Create an IMMEDIATE name header consisting of count char and name chars.
; Mostly called by macro INAME, but this factoring is necessary because of chars like * / # in Forth names.
inamemanque macro aName,linkpointer
linkme linkpointer
namecntr = 0
irpc x,aName
namecntr = namecntr+1
endm
countcell <namecntr or immedMask>
unicode aName
align cell
endm
; Create an IMMEDIATE name header consisting of count char and name chars as above,
; but also define a token label for it. This is the normal call.
iname macro aName,linkpointer
inamemanque aName,linkpointer
fw_&aName:
endm
; Create non-IMMEDIATE header for FORTH-WORDLIST
fname macro aName
nayme aName,flinkptr
endm
; Create an IMMEDIATE header for FORTH-WORDLIST
finame macro aName
iname aName,flinkptr
endm
; Create non-IMMEDATE header without label for FORTH-WORDLIST
fnamemanque macro aName
namemanque aName,flinkptr
endm
; Create IMMEDIATE header without label for FORTH-WORDLIST
finamemanque macro aName
inamemanque aName,flinkptr
endm
; Create non-IMMEDIATE header for INTERNALS-WORDLIST
zname macro aName
nayme aName,zlinkptr
endm
; Create an IMMEDIATE header for INTERNALS-WORDLIST
ziname macro aName
iname aName,zlinkptr
endm
; Create non-IMMEDATE header without label for INTERNALS-WORDLIST
znamemanque macro aName
namemanque aName,zlinkptr
endm
; Create IMMEDIATE header without label for INTERNALS-WORDLIST
zinamemanque macro aName
inamemanque aName,zlinkptr
endm
; Create non-IMMEDIATE header for NONSTANDARD-WORDLIST
nname macro aName
nayme aName,nlinkptr
endm
; Create an IMMEDIATE header for NONSTANDARD-WORDLIST
niname macro aName
iname aName,nlinkptr
endm
; Create non-IMMEDATE header without label for NONSTANDARD-WORDLIST
nnamemanque macro aName
namemanque aName,nlinkptr
endm
; Create IMMEDIATE header without label for NONSTANDARD-WORDLIST
ninamemanque macro aName
inamemanque aName,nlinkptr
endm
; Create non-IMMEDIATE header for SYSTEM-WORDLIST
sname macro aName
nayme aName,slinkptr
endm
; Create an IMMEDIATE header for SYSTEM-WORDLIST
siname macro aName
iname aName,slinkptr
endm
; Create non-IMMEDATE header without label for SYSTEM-WORDLIST
snamemanque macro aName
namemanque aName,slinkptr
endm
; Create IMMEDIATE header without label for SYSTEM-WORDLIST
sinamemanque macro aName
inamemanque aName,slinkptr
endm
; Assemble execution token into a Forth definition
; Kernel tokens are flat addresses
ctok macro aName
dd fw_&aName ;; for kernel tokens
endm
;--( Execution Macros )
; Push an item on the return stack
pushrp macro source
sub rp,cell
mov [rp],source
endm
; Pop an item from the return stack and discard
poprp macro
add rp,cell
endm
; Pop an item for the return stack to a destination
poprpto macro dest
mov dest,[rp]
poprp
endm
; The Forth NEXT routine
; User dict tokens are distinguised from kernel tokens by their "odd"-ness.
; Here is the inner next routine once WP is loaded with a token:
innext macro ;; on entry, WP already contains token found by instruction pointer
local kerntok,kernex
btr wp,userdictbit ;; user dict tokens are (addr|userdictbit)-cp
jnc SHORT kerntok
add wp,cp ;; add base
kerntok:
mov edx,[wp] ;; deference indirect pointer to execution engine
btr edx,userdictbit ;; user pointers to kern exe engines are (addr|userdictbit) - cp
jnc SHORT kernex
add edx,cp ;; add base
kernex:
jmp edx
endm
; Here is the entire next routine:
next macro
lodsd ;; WP (EAX) := @IP++
innext ;; execute the token in WP
endm
; Used by conditionals compiled in user dictionary .. token is in WP
dereftok macro
local kerntok
btr wp,userdictbit ;; user dict tokens are (addr|userdictbit)-cp
jnc SHORT kerntok
add wp,cp ;; add base
kerntok:
endm
;--( Compilation Macros )
docode macro
dd $+cell
endm
defers macro ;; value must be init'ed at boot time
ctok DODEFER
dd varptr
varptr = varptr + cell
endm
literal macro aLit
ctok DOLIT
dd aLit
endm
charlit macro aChar ;; accepts ASCII only
ctok DOLIT
db aChar,0,0,0
endm
compif macro aLabel ;; also WHILE
ctok DOIF
dd aLabel
endm
compelse macro aLabel ;; also REPEAT AGAIN
ctok DOELSE
dd aLabel
endm
compuntil macro aLabel
ctok DOUNTIL
dd aLabel
endm
compdo macro aLabel
ctok DODO
dd aLabel
endm
comploop macro aLabel
ctok DOLOOP
dd aLabel
endm
compqdo macro aLabel
ctok DOQDO
dd aLabel
endm
compplloop macro aLabel
ctok DOPLUSLOOP
dd aLabel
endm
;-----------------------;
; Forth Data Space ;
;-----------------------;
;--( Variables )
avar lastCatch ; holds catch frame pointer
avar lastCaught ; holds IP pointing to cell following THROW
avar conMode ; Holds Console Mode
avar lastError ; TRUE for no error or an error code after funcalls
avar outChar ; hold one char for output
avar ntConEBP ; holds value of EBP from startup
avar ntConESP ; holds value of ESP from startup
avar rpzero ; holds Forth's initial setting of RP
avar memHandle ; pointer to allocated memory block
avar stdIn ; Console handle
avar stdOut ; Console handle
avar stdErr ; Console handle
avar datap ; Returned by HERE
avar dictp ; Dictionary space pointer
avar flinkp ; Last FORTH-WORDLIST link
avar zlinkp ; Last INTERNALS-WORDLIST link
avar nlinkp ; Last NONSTANDARD-WORDLIST link
avar slinkp ; Last SYSTEM-WORDLIST link
avar wllink ; points to last wordlist in chain
avar endq ; TRUE when input stream found to be at end in FIND
avar nonaming ; TRUE if the current definition was initiated by :NONAME
avar var_hld ; used by <# # #S HOLD #>
avar var_state ; STATE variable
avar var_blk ; BLK variable
avar var_scr ; SCR variable
avar var_srcid ; SOURCE-ID variable
avar var_numtib ; #TIB variable
avar var_tib ; 'TIB variable
avar var_to_in ; >IN variable
avar var_base ; BASE variable
avar var_dpl ; DPL variable, holds position of "dot" (.) in number input
avar last ; holds link token of last entry added to dictionary
avar cstack ; saved stack pointer during compilation
avar current ; current compilation wordlist
avar blockFile ; holds handle for active BLOCK file
avar blockNum ; holds number of block in buffer
avar updated ; TRUE if block has been updated
avar inDefinition ; TRUE if compiling a : (colon) or :NONAME definition
avar var_ferror ; holds error from last bum file operation
;--( Larger Items )
allotCells searchOrder,searchOrderSize ; search order array
;--( Buffers )
allotCells wordBuffer,(256*tchar)/cell ; holds result of WORD
allotCells stringBuffer,(256*tchar)/cell ; holds result of interpretive S"
allotCells asciizBuffer,256/cell ; holds converted asciiz strings for syscalls
allotCells blockBuffer,(blockSize*tchar)/cell ; our single block buffer
allotCells ticktib,(tibsize*tchar)/cell ; input buffer
allotCells tickpad,(128*tchar)/cell ; pad buffer
allotCells tickftib,(tibsize*tchar)/cell ; file input buffer
allotCells ticknum,(128*tchar)/cell ; numeric output conversion buffer
ticknumend equ varptr ; end of numeric conversion buffer
allotCells rlBuffer,((rlbuffsize+2)*tchar)/cell
; READ-LINE buffer, 256 + 2 for EOL chars
allotCells zeroBuffer,(tibsize*tchar)/cell ; CREATE-FILE needs a zero-pad buffer
; Can't expect the user to do it.
; END of jax4th.i